home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / System source / Ovl < prev    next >
Text File  |  1993-05-31  |  7KB  |  228 lines
  1. \ Module - overlay support for Yerk modules
  2. \ 11/19/84  CBD Version 1
  3. \  7/10/86  cdn rewrote reloc in code
  4. \  3/22/91    rfl prettied up (.mod)
  5. \  4/29/93    rfl    when modules are loaded, search for 'proc' and set with a5,a3
  6. \  5/01/93  rfl removed n>count since defined in nuc
  7. \  5/29/93    rfl    getPtrSize now takes relative pointer as input.
  8. \  5/31/93    rfl    added Mike Hore's trav words
  9. Decimal
  10.  
  11. \ ( n -- 2^n )
  12. : 2**  1 swap << ;
  13.  
  14. \ the bitMap class is an array of bits - allocation is #bytes
  15. :CLASS bitMap  <Super Object  1 <indexed    \ for allocation only
  16.  
  17.     \ ( ind -- byte )  return the byte at ind
  18.     :M  BYTEAT:   ?range at1  ;M
  19.  
  20.     \ ( val ind -- )  store byte value at ind
  21.     :M  BYTETO:   ?range to1  ;M
  22.  
  23.     \ ( ind -- 1 OR 0 )  get bit #ind
  24.     :M  AT:  abs 8 /mod   byteAt: self  swap 2** And 0= 0=  ;M
  25.  
  26.     \ ( 1 OR 0 ind -- )  store bit #ind
  27.     :M  TO:  { val ind \ bit# -- }  ind  abs 8 /mod -> ind   -> bit#
  28.         ind byteAt: self  bit# 2** Or  ind byteTo: self ;M
  29.  
  30.     :M  SET:   1 swap To: self  ;M
  31.  
  32. ;CLASS
  33.  
  34. 0 Value Bits                \ will hold ptr to base of bitMap
  35. 'type BIN Constant binType    \ file type for overlays
  36. \ 6 constant parmsLen        \ 0:1=len, 2:5=original addr
  37.  
  38. \ ( addr len offset bits -- )  code version of module relocate
  39. Create reloc
  40.     $ 205f w,        \        move.l    (sp)+,a0    ; bits
  41.     $ 41f38804 ,    \        lea        4(a3,a0.l),a0
  42.     $ 201f w,        \        move.l    (sp)+,d0    ; offset (relocation factor)
  43.     $ 221f w,        \        move.l    (sp)+,d1    ; len
  44.     $ 225f w,        \        move.l    (sp)+,a1    ; base addr
  45.     $ 43f39800 ,    \        lea        0(a3,a1.l),a1
  46.  
  47.     $ 4284 w,        \        clr.l    d4            ; init module relative position
  48.     $ 143c0001 ,    \        move.b    #1,d2        ; init mask
  49.  
  50.     $ 1c02 w,        \ loop    move.b    d2,d6
  51.     $ cc3c0001 ,    \        and.b    #1,d6        ; time to get new byte?
  52.     $ 6702 w,        \        beq.s    test        ; no, still using same byte
  53.     $ 1618 w,        \        move.b    (a0)+,d3    ; get next "bits" byte
  54.  
  55.     $ 1c03 w,        \ test    move.b    d3,d6
  56.     $ cc02 w,        \        and.b    d2,d6        ; test this bit
  57.     $ 6704 w,        \        beq.s    nextb
  58.  
  59.     $ d1b14800 ,    \        add.l    d0,0(a1,d4.l)    ; add reloc factor
  60.  
  61.     $ e31a w,        \ nextb    rol.b    #1,d2        ; shift mask
  62.     $ 5484 w,        \        addq.l    #2,d4        ; increment offset into module
  63.     $ 5381 w,        \        subq.l    #1,d1
  64.     $ 66e4 w,        \        bne.s    loop        ; decrement len (bit map)
  65.  
  66.     next,
  67.  
  68. \ ( ovLen -- bitmapLen )  Find bitmap length for overlay
  69. : bitsLen  abs 16 /mod 2* swap IF 2+ THEN 8+ ;
  70.  
  71. \ leave name of binary file for module
  72. ( addr len -- addr1 len1 )
  73. : binName { addr len -- }
  74.     addr pad len cmove
  75.     " .BIN" pad len + swap cmove
  76.     pad len 4+ ;
  77.  
  78. \ ( nfa -- base )  load and relocate a binary module from it's data file
  79. : loadBin  { \ len bLen org base -- }
  80.     n>count binName name: fFcb
  81.     openReadOnly: fFcb ?error 138
  82.     size: fFcb 6 ( parmsLen ) -        \ find parms
  83.     moveto: fFcb drop
  84.     pad 6 ( parmsLen ) read: fFcb ?error 141
  85.     0 moveTo: fFcb drop
  86.     pad w@ -> len pad 2+ @ -> org    \ get parms
  87.     len ovBlock -> base                \ get block for module code
  88.     base len read: fFcb  ?error 141
  89.     len bitsLen -> bLen                \ length of bitmap in bytes
  90.     bLen 4+ ovBlock 4+ -> bits        \ heap for bitmap
  91.     bits 4- bLen read: fFcb ?error 141
  92.     close: fFcb  drop
  93.     bits 4- @ ' bitmap <> ?error 142    \ sentinel
  94.     base len base org - bits reloc        \ relocate the module
  95.     dispose> bits  base  ;
  96.  
  97. Handle mHndl
  98.  
  99. \ ( resID -- handle )  load and relocate a binary module from it's resource
  100. : loadBinR { \ len org -- }
  101.     GetRes CODE -dup 0= ?error 138
  102.     dup put: mHndl        \ leave copy of handle on the stack
  103.     ptr: mHndl size: mHndl + 6 -
  104.     dup w@ -> len  2+ @ -> org
  105.     ptr: mHndl len + 4+ -> bits
  106.     ptr: mHndl len over org - bits reloc
  107.     len setSize: mHndl    \ dump bitMap
  108. ;
  109.  
  110. : ?mod   @ modCode = ;
  111.  
  112. \ locking a module prevents the Yerk growZone routine from
  113. \ purging it while it is executing.
  114. \ ( cfa -- )  lock/unlock the module whose cfa is on stack
  115. : mUnlock   12 + 0 swap c! ;
  116. : mLock     12 + 1 swap c! ;
  117. : ?mlock    12 + c@ ;    \ true if module is locked
  118.  
  119. create getPtrSize popA0 $ d1cb w, $ a021 w, pushD0 next,
  120. create recoverHndl popA0 $ a128 w, pushA0 next,
  121. create geta3a5   ( -- a3 a5)  $ 2f0b w, $ 2f0d w,   next,
  122.  
  123. \ named input parm replace is true if handle,, false if ptr
  124. : fixProcMod { ptr replace \ len myString addr -- ptr }
  125.     replace IF ptr +base recoverHndl getHSize
  126.             ELSE ptr getPtrSize
  127.             THEN -> len
  128.     0 -> replace
  129.     heap> string -> myString new: myString
  130.     ptr len put: myString
  131.     start: mystring
  132.     BEGIN " proc" indexof: myString
  133.     WHILE ptr: myString + 4+ -> addr
  134.           getA3A5 addr ! addr 4+ !
  135.           where: myString 4+ moveto: myString
  136.           true -> replace
  137.     REPEAT
  138.     replace IF get: myString ptr swap cmove THEN
  139.     release: myString dispose> myString
  140.     ptr ;
  141.  
  142. \ mcfa structure to define a module. This will reside in the
  143. \ resident dictionary, being the link between resident words and
  144. \ words in the module.
  145.  
  146. 3 codeFields
  147.  
  148. \ ( addr -- )  Release the heap storage for the module
  149.     Do..  dup  c@ 0=    \ unlocked ?
  150.         IF  dup @ 0 <>    \ unlocked and loaded?
  151.             IF dup 10 + w@
  152.                 IF dup 12 + @ $ a9a3 Trap    \ call ReleaseResource
  153.                 ELSE dup @ killPtr THEN
  154.             THEN   0 swap !
  155.         ELSE  drop
  156.         THEN
  157.     ..End
  158.  
  159. \ ( offs addr -- )  execute the export vector at offset in module
  160.     Do..  dup 12 - >R        \ save the address of the mod's cfa
  161.         R execute            \ exec 0cfa to load the module
  162.         R mlock                \ lock the module while it executes
  163.         @ $ FFFFFF and >R R + @ execute    \ execute the import word
  164.         R> c@ IF R> drop    \ leave module locked?
  165.             ELSE R> mUnlock THEN
  166.     ..End
  167.  
  168. \ ( addr -- )  Load the module if not loaded
  169.     Do..  dup @ 0=
  170.         IF dup 10 + w@ -dup    \ load module and update pointer to base
  171.             IF loadBinR 2dup swap 12 + ! >ptr true    \ resource based module
  172.             ELSE dup 12 - >name loadBin false         \ file based module    
  173.             THEN
  174.             fixProcMod                            \ search all :proc defs and fill w/a5,a3
  175.             swap !
  176.         ELSE drop
  177.         THEN
  178.     ..End
  179.  
  180. \ module def data consists of |^moduleBase|^lastImport|#imports|resID|mHandle|
  181. : modDef  Build 0, 0, 0 w, 0 w, 0, ..End
  182.  
  183. false value endTrav?    \ May be set from within a trav handler to terminate the trav
  184.  
  185. \ traverse the dictionary, applying passed-in proc to each cfa...start from nfa
  186. : (trav)  { theWord parm nfa -- } 
  187.     false -> endTrav? nfa
  188.     BEGIN  1 traverse align dup 4+ parm exec> theWord
  189.         @ dup 0= endTrav? or
  190.     UNTIL  drop ;
  191.  
  192. : trav latest (trav) ;
  193.  
  194. : travFrom ( nfa --) (trav) ;
  195.  
  196. \ handler to release selected modules
  197. : ?disp  { theCfa size -- }
  198.     theCfa ?mod  \ if this is a module
  199.     IF  free size <                \ if we still need space
  200.         IF   theCfa 8+ execute    \ 2cfa is Dispose>
  201.         THEN
  202.     THEN ;
  203.  
  204. \ Release will free all unlocked modules on a small Mac,
  205. \ and frees 150K bytes on a large Mac.
  206. : release   'c ?disp 150000 trav ;
  207.  
  208. \ unlock and release
  209. : (purge)  { theCfa size -- }   theCfa ?mod
  210.     IF  0 theCfa 4+ 8+ c!  theCfa size  ?disp
  211.     THEN ;
  212.  
  213. \ unlock and free all modules ( Forward reference in file: Base )
  214. :F purge  'c (purge) 100000000 trav ;F
  215.  
  216. \ ( #bytes -- ) release modules until #bytes are available
  217. : need   freeblk . 'c ?disp swap  trav  ;
  218.  
  219. \ list existing modules and their load status
  220. : (.mod)  { theCfa size -- }  curs -curs theCfa  ?mod
  221.     IF  cr theCfa >name id.  @xy swap drop 90 swap gotoxy
  222.         theCfa 12 + @ $ ffffff and .h
  223.         theCfa ?mLock IF type# 174 ( ***Locked***) THEN
  224.     THEN  -> curs ;
  225.  
  226. \ list modules and their load status
  227. : .mods   'c (.mod)  0 trav  ;
  228.